home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
t3_1
/
risc_src.lha
/
risc_sources
/
xlib
/
xwss.t
< prev
Wrap
Text File
|
1990-06-07
|
16KB
|
538 lines
;;; This module contains the interface routines which are not automatically
;;; generated.
(herald xwss (env tsys (xlib interface)))
;;; Internal functions.
(define (POINTER-LIST->STRING lst typep)
(do ((i 0 (+ i 1))
(array (make-bytev (* 4 (length lst))))
(lst lst (cdr lst)))
((null? lst)
array)
(set-mref-pointer! array i (typep (car lst)))))
(define (ARRAY-POINTER->LIST arrayptr count type)
(let ((arrayptr (c->extend arrayptr)))
(iterate loop ((x 0))
(if (eq? x count)
'()
(cons (if type
(cons type (extend-elt arrayptr x))
(extend-elt arrayptr x))
(loop (+ x 1)))))))
(define-foreign xfree ("XFree" (in rep/c-pointer)) ignore)
(define (CHK-STRING x)
(if (string? x) x (error "Argument is incorrect type: ~s" x)))
(define (STRING-LIST->STRING-ARRAY strings)
(let ((texts (map (lambda (x) (string-text (string->asciz! (copy-string x)))) strings))
(str (make-bytev (fx* (length strings) 4))))
(do ((i 0 (fx+ i 4))
(texts texts (cdr texts)))
((null? texts) str)
(set-mref-pointer! str i
(fx+ (descriptor->fixnum (car texts)) 1)))))
(define (STRING-ARRAY->STRING-LIST ptr cnt)
(let ((ptr (c->extend ptr)))
(iterate loop ((x 0))
(if (eq? x cnt)
'()
(cons (asciz->string (extend-elt ptr x))
(loop (fx+ x 1)))))))
(define (COPY-PTR-TO-STRUCT ptr struct)
(let* ((array (cdr struct))
(size (bytev-length array)))
(iterate loop ((x 0))
(cond ((neq? x size)
(set-mref-pointer! array x (mref-pointer ptr x))
(loop (+ x 4)))))
struct))
(define (ARRAY-STRUCT->LIST ptr count make-struct)
(let ((ptr (c->extend ptr)))
(iterate loop ((ptr ptr) (x count))
(if (eq? x 0)
'()
(let* ((struct (copy-ptr-to-struct ptr (make-struct)))
(size (fx/ (bytev-length (cdr struct)) 4)))
(cons struct (loop (make-pointer ptr size) (- x 1))))))))
(define (STRUCT-LIST->bytev lst typep)
(apply bytev-append
(map typep lst)))
;;; Misc. Utility functions.
(define (NULL-POINTER? x) (or (eq? x 0) (and (pair? x) (eq? (cdr x) 0))))
(define (POINTER-TYPE x) (and (pair? x) (car x)))
(define (POINTER-VALUE x) (and (pair? x) (cdr x)))
(define (TYPE/VALUE->POINTER type value) (cons type value))
;;; Chapter 2.
(define-foreign xfree* ("XFree" (in rep/c-pointer)) ignore)
(define (YFREE ptr)
(if (pair? ptr)
(xfree* (pointer-value ptr))
(xfree* ptr))
'#f)
;;; Chapter 4.
(define-foreign xquerytree*
("XQueryTree" (in rep/c-pointer)
(in rep/integer)
(in rep/extend)
(in rep/extend)
(in rep/extend)
(in rep/extend))
int)
(define (YQUERYTREE dpy window)
(let ((dpy (chk-displayp dpy))
(root (make-bytev 4))
(parent (make-bytev 4))
(children (make-bytev 4))
(nchildren (make-bytev 4)))
(if (eq? 0 (xquerytree* dpy window root parent children nchildren))
'#f
(let ((result (list (mref-integer root 0)
(mref-integer parent 0)
(array-pointer->list
(mref-pointer children 0)
(mref-integer nchildren 0)
'#f))))
(xfree (mref-pointer children 0))
result))))
(define-foreign xgetatomname*
("XGetAtomName" (in rep/c-pointer) (in rep/integer)) rep/pointer)
(define (YGETATOMNAME dpy atom)
(let* ((dpy (chk-displayp dpy))
(result (xgetatomname* dpy atom))
(name (asciz->string result)))
(xfree result)
name))
(define-foreign xlistproperties*
("XListProperties" (in rep/c-pointer) (in rep/integer)
(in rep/extend))
rep/pointer)
(define (YLISTPROPERTIES dpy window)
(let* ((dpy (chk-displayp dpy))
(n_props (make-bytev 4))
(c-atomap (xlistproperties* dpy window n_props))
(limit (fx* (mref-integer n_props 0) 4))
(atomap (c->extend c-atomap)))
(iterate loop ((i 0))
(if (eq? i limit)
(begin (xfree c-atomap)
'())
(cons (mref-integer atomap i) (loop (+ i 4)))))))
;;; Chapter 6.
(define-foreign xlistfonts*
("XListFonts" (in rep/c-pointer) (in rep/string) (in rep/integer)
(in rep/extend))
rep/pointer)
(define-foreign xfreefontnames*
("XFreeFontNames" (in rep/c-pointer))
ignore)
(define (YLISTFONTS dpy pattern maxnames)
(let* ((dpy (chk-displayp dpy))
(pattern (chk-string pattern))
(count (make-bytev 4))
(charpap (xlistfonts* dpy pattern maxnames count))
(result (string-array->string-list charpap (mref-integer count 0))))
(xfreefontnames* charpap)
result))
(define-foreign xlistfontswithinfo*
("XListFontsWithInfo" (in rep/c-pointer)
(in rep/string)
(in rep/integer)
(in rep/extend)
(in rep/extend))
rep/pointer)
(define-foreign xfreefontinfo*
("XFreeFontInfo" (in rep/c-pointer) (in rep/c-pointer) (in rep/integer))
ignore)
(define (YLISTFONTSWITHINFO dpy pattern maxnames)
(let* ((dpy (chk-displayp dpy))
(pattern (chk-string pattern))
(count_ret (make-bytev 4))
(info_ret (make-bytev 4))
(charap (xlistfontswithinfo* dpy pattern maxnames count_ret
info_ret))
(count (mref-integer count_ret 0))
(info (mref-pointer info_ret 0))
(fonts (array-struct->list info
count
make-xfontstruct))
(names (string-array->string-list charap count)))
(xfreefontinfo* charap info count)
(map cons names fonts)))
(define-foreign xsetfontpath*
("XSetFontPath" (in rep/c-pointer) (in rep/c-pointer) (in rep/integer))
ignore)
(define (YSETFONTPATH dpy directories)
(let ((dpy (chk-displayp dpy))
(charap (string-list->string-array directories)))
(xsetfontpath* dpy charap (length directories))
directories))
(define-foreign xgetfontpath*
("XGetFontPath" (in rep/c-pointer) (in rep/extend)) rep/pointer)
(define-foreign xfreefontpath*
("XFreeFontPath" (in rep/c-pointer))
ignore)
(define (YGETFONTPATH dpy)
(let* ((dpy (chk-displayp dpy))
(npaths (make-bytev 4))
(charap (xgetfontpath* dpy npaths))
(result (string-array->string-list charap (mref-integer npaths 0))))
(xfreefontpath* charap)
result))
;;; Chapter 7.
(define-foreign xlistinstalledcolormaps*
("XListInstalledColormaps" (in rep/c-pointer) (in rep/integer) (in rep/extend))
rep/pointer)
(define (YLISTINSTALLEDCOLORMAPS dpy window)
(let* ((dpy (chk-displayp dpy))
(n_ret (make-bytev 4))
(cmapaddr (xlistinstalledcolormaps* dpy window n_ret))
(result (iterate loop ((x (mref-integer n_ret 0))
(cmapaddr (c->extend cmapaddr)))
(if (eq? x 0)
'()
(cons (mref-integer cmapaddr 0)
(loop (fx- x 1) (make-pointer cmapaddr 0)))))))
(xfree cmapaddr)
result))
#|
(define (FAMILY-ADDRESS->XHOSTADDRESS family address)
(let ((array (string-append (make-string 12) address)))
(c-int-set! array 0 family)
(c-int-set! array 4 (string-length address))
(c-unsigned-set! array 8 ((lap (x) (_TSCP (PLUS (INT x) 3))) array))
array))
|#
;;; Chapter 8.
(define-foreign xnextevent*
("XNextEvent" (in rep/pointer) (in rep/extend)) ignore)
(define (YNEXTEVENT dpy event)
(xnextevent* (chk-displayp dpy) (chk-xeventp event))
'#f)
(define-foreign unix_select
("select" (in rep/integer) (in rep/extend)
(in rep/c-pointer) (in rep/c-pointer) (in rep/extend))
rep/integer)
(define (YSELECT dpy . ports-time)
(let* ((timeval (make-bytev 8))
(ports (iterate loop ((x ports-time))
(cond ((fx> (length x) 2)
(cons (car x) (loop (cdr x))))
(else
(set-mref-integer! timeval 0 (car x))
(set-mref-integer! timeval 4 (cadr x))
'()))))
(nfds 0)
(file->result (make-vector 32 '#f))
(read-mask (let* ((mask (make-bytev 4))
(xfile (xconnectionnumber dpy)))
(vset file->result xfile dpy)
(set-mref-integer! mask 0
(iterate loop ((ports ports)
(mask (fixnum-ashl 1 xfile))
(maxfile xfile))
(if ports
(let* ((port (car ports))
(x (iob-xeno (port->iob port))))
(vset file->result x port)
(loop (cdr ports)
(fixnum-logior
(fixnum-ashl 1 x)
mask)
(max x maxfile)))
(block (set nfds (fx+ maxfile 1))
mask))))
mask)))
(cond ((not (zero? (xpending dpy))) dpy)
((iterate loop ((ports ports))
(if ports
(if (char-ready? (car ports))
(car ports)
(loop (cdr ports)))
'#f)))
(else (let* ((nfiles (unix_select nfds read-mask 0 0 timeval))
(bits (mref-integer read-mask 0)))
(if (positive? nfiles)
(iterate loop ((mask 1) (index 0))
(if (not (zero? (fixnum-logand bits mask)))
(vref file->result index)
(loop (fx+ mask mask) (fx+ index 1))))
'#f))))))
(define-foreign xgetmotionevents*
("XGetMotionEvents" (in rep/c-pointer) (in rep/integer)
(in rep/integer) (in rep/integer)
(in rep/extend))
rep/pointer)
(define (YGETMOTIONEVENTS dpy window start stop)
(let* ((dpy (chk-displayp dpy))
(nevents_ret (make-bytev 4))
(rawptr (xgetmotionevents* dpy window start stop nevents_ret))
(ptr (c->extend rawptr))
(result (iterate loop ((x (mref-integer nevents_ret 0)) (i 0))
(if (eq? x 0)
'()
(cons (list (mref-integer ptr i)
(mref-16-s ptr (fx+ i 4))
(mref-16-s ptr (fx+ i 6)))
(loop (fx- x 1) (fx+ i 6)))))))
(xfree rawptr)
result))
;;; Chapter 9.
(define-foreign xsetstandardproperties*
("XSetStandardProperties" (in rep/c-pointer)
(in rep/integer)
(in rep/string)
(in rep/string)
(in rep/integer)
(in rep/c-pointer)
(in rep/integer)
(in rep/c-pointer))
ignore)
(define (YSETSTANDARDPROPERTIES dpy window name icon_string icon_pixmap
commands hints)
(let ((dpy (chk-displayp dpy))
(name (chk-string name))
(icon_string (chk-string icon_string))
(commands (string-list->string-array commands))
(hints (chk-xsizehintsp hints)))
(xsetstandardproperties* dpy window name icon_string icon_pixmap
commands (length commands) hints)
'#f))
(define-foreign xfetchname*
("XFetchName" (in rep/c-pointer) (in rep/integer) (in rep/extend))
rep/integer)
(define (YFETCHNAME dpy window)
(let* ((dpy (chk-displayp dpy))
(name_ret (make-bytev 4))
(status (xfetchname* dpy window name_ret))
(name (mref-pointer name_ret 0))
(string (if (or (eq? status 0) (eq? name 0))
'#f
(asciz->string name))))
(if string (xfree name))
string))
(define-foreign xgeticonname*
("XGetIconName" (in rep/c-pointer) (in rep/integer) (in rep/extend))
rep/integer)
(define (YGETICONNAME dpy window)
(let* ((dpy (chk-displayp dpy))
(name_ret (make-bytev 4))
(status (xgeticonname* dpy window name_ret))
(name (mref-pointer name_ret 0))
(string (if (or (eq? status 0) (eq? name 0))
'#f
(asciz->string name))))
(if string (xfree name))
string))
(define-foreign xsetcommand*
("XSetCommand" (in rep/c-pointer) (in rep/integer)
(in rep/c-pointer) (rep/integer))
ignore)
(define (YSETCOMMAND dpy window commands)
(let ((dpy (chk-displayp dpy))
(commands-array (string-list->string-array commands)))
(xsetcommand* dpy window commands-array (length commands))
'#f))
(define-foreign xgetwmhints*
("XGetWMHints" (in rep/c-pointer) (in rep/integer))
rep/pointer)
(define (YGETWMHINTS dpy window)
(let* ((dpy (chk-displayp dpy))
(ptr (xgetwmhints* dpy window))
(result (if (eq? ptr 0)
'#f
(copy-ptr-to-struct ptr (make-xwmhints)))))
(if result (xfree ptr))
result))
(define-foreign xseticonsizes*
("XSetIconSizes" (in rep/c-pointer) (in rep/integer)
(in rep/c-pointer) (in rep/integer))
ignore)
(define (YSETICONSIZES dpy window iconsizelist)
(let* ((dpy (chk-displayp dpy))
(arrayp (struct-list->bytev iconsizelist chk-xiconsizep)))
(xseticonsizes* dpy window arrayp (length iconsizelist))
'#f))
(define-foreign xgeticonsizes*
("XGetIconSizes" (in rep/c-pointer) (in rep/integer)
(in rep/extend) (in rep/extend))
rep/integer)
(define (YGETICONSIZES dpy window)
(let* ((dpy (chk-displayp dpy))
(array_ret (make-bytev 4))
(count_ret (make-bytev 4))
(status (xgeticonsizes* dpy window array_ret count_ret))
(array (mref-pointer array_ret 0))
(count (mref-integer count_ret 0))
(result (if (neq? status 0)
(array-struct->list array count make-xiconsize)
'#f)))
(if result (xfree array))
result))
(define-foreign xsetclasshint*
("XSetClassHint" (in rep/c-pointer) (in rep/integer) (in rep/c-extend))
ignore)
(define (YSETCLASSHINT dpy window name-class)
(let* ((dpy (chk-displayp dpy))
(hint (string-list->string-array name-class)))
(xsetclasshint* dpy window hint)
'#f))
(define-foreign xgetclasshint*
("XGetClassHint" (in rep/c-pointer) (in rep/integer) (in rep/extend))
rep/integer)
(define (YGETCLASSHINT dpy window)
(let* ((dpy (chk-displayp dpy))
(hint_ret (make-bytev 4))
(status (xgetclasshint* dpy window hint_ret))
(hint (mref-pointer hint_ret 0)))
(if (eq? status 0)
'#f
(let ((result (string-array->string-list hint 2)))
(xfree (mref-pointer hint 0))
(xfree (mref-pointer hint 4))
result))))
;;; Chapter 10
(define-foreign xlookupstring*
("XLookupString" (in rep/extend) (in rep/string) (in rep/integer)
(in rep/c-pointer) (in rep/c-pointer)) rep/integer)
(define XLOOKUPSTRING-BUFFER (make-string 50))
(define (YLOOKUPSTRING event . opt)
(let* ((event (chk-xeventp event))
(keysym (if (and opt (car opt)) (make-bytev 4) 0))
(status (if (= (length opt) 2) (chk-xcomposestatusp (cadr opt)) 0))
(result (xlookupstring* event xlookupstring-buffer 50 keysym
status)))
(if opt
(list (substring xlookupstring-buffer 0 result)
(if (car opt) (mref-integer keysym 0) '#f))
(substring xlookupstring-buffer 0 result))))
;;; Write-around for XrmGetResource in the standard Scheme->C X library:
(DEFINE-FOREIGN XRMGETRESOURCE*
("XrmGetResource" (IN REP/C-POINTER)
(IN REP/string)
(IN REP/string)
(IN REP/EXTEND)
(IN REP/EXTEND))
REP/INTEGER)
(DEFINE
(XRMGETRESOURCE DB NAME_STR CLASS_STR)
(LET*
((DB (CHK-XRMdatabase DB))
(NAME_STR
(IF
(STRING? name_str)
(string->asciz! name_str)
(ERROR "Argument is incorrect type: ~s" name_str)))
(CLASS_STR
(IF
(STRING? class_str)
(string->asciz! class_str)
(ERROR "Argument is incorrect type: ~s" class_str)))
(PTYPE_STR (MAKE-bytev 4))
(PVALUE (MAKE-xrmvalue))
(RETURN-VALUE (XRMGETRESOURCE* DB NAME_STR CLASS_STR PTYPE_STR
(chk-xrmvalueptr PVALUE))))
(return
RETURN-VALUE
(mref-pointer PTYPE_STR 0)
pvalue)))
(define (YrmGetResource db name_str class_str)
(receive (return-code type-chara rmvalue) (XrmGetResource db name_str class_str)
(if (zero? return-code)
'()
(let ((type-string (asciz->string type-chara)))
(if (equal? type-string "String")
(asciz->string (chk-charap (xrmvalue-addr rmvalue)))
(error "Unimplemented resource type in YrmGetResource"
type-string))))))
(define (YrmMergeDatabases new into)
(let ((into-p (make-bytev 4)))
(set-mref-pointer! into-p 0 (chk-xrmdatabase into))
(XrmMergeDatabases new (type/value->pointer 'xrmdatabasep into-p))
(type/value->pointer 'xrmdatabase (mref-pointer into-p 0))))